
Attribute VB_Name = "Crop"
Global smv As String

Function CropText(Optional pYES As Boolean = True)
  'pYES - возвращать отрывок (yes) или массив
  'символы окончания предложений:
  endP = Array("!!!", "!..", "!", "???", "?!", "?..", "?", "...", ".")
  smv = " " & [smvList] 'допустимые символы в тексте
  fs = "|" 'фиктивный разделитель
  cE = "00" 'максимум возможных окончаний 100
  lM = rwOpts("lp") 'длина запоминаемого текста (слов)
  sW = rwOpts("lw") 'достаточная длина слова для подсчёта (симв.), включая символы
  ovW = rwOpts("pw") 'допустимая прибавка к отрывку (слов)
  maxl = rwOpts("ml") 'максимум символов в слове
  txt_path = [ft] 'текстовый файл для набора
  Dim mPs() As String 'массив отрывков
  Dim z As Long 'счётчик отрывков
  
  If txt_path Like "<Clipboard*>" Then 'если в качестве источника указан буфер обмена
    If txt_path = IDclb Then 'при совпадении идентификатора, продолжаем набор
    Else 'иначе сброс позиционирования (np и nw) и смена ID буфера
      rwOpts ("ap"), 0: rwOpts "np", 0
      rwOpts ("aw"), 0: rwOpts "nw", 0
      [ft] = IDclb
    End If
    iText = IDclb(1)
    If Len(iText) = 0 Then
      MsgBox "Буфер обмена пуст, скопируйте любой текст или укажите файл для набора.", 16
      Exit Function
    End If
  Else
    txt_path = IIf(InStr(txt_path, "\") = 0, ThisWorkbook.Path & "\", "") & txt_path
    If Dir(txt_path) = "" Then 'проверяем наличие файла
      MsgBox "Не удалось найти файл *.txt по указанному пути!", 16
      Exit Function
    Else
      Open txt_path For Input As #1 'считываем весь текст
         iText = Input(LOF(1), #1)
      Close #1
    End If
  
   'проверяем - возможно текст уже размечен:
    If InStr(iText, fs) > 0 Then mPs = Split(iText, fs): GoTo finish
  End If
  
  With Sheets("Parts").[B5] 'тип разбивки текста
    tmp2 = Split(.Validation.Formula1, ";")
    For i = 0 To UBound(tmp2)
      If tmp2(i) = .Value2 Then optV = i + 1: Exit For
    Next
  End With
    
  iText = Replace(Replace(iText, Chr(10), " "), Chr(13), " ") 'убираем абзацы
  While InStr(iText, "  ") > 0 'убираем двойные пробелы
    iText = Replace(iText, "  ", " ")
  Wend
  
  For n = 1 To Len(iText) ' проверка текста на валидность
    cod = Asc(Mid(iText, n, 1))
    If cod > 191 And cod < 256 Then 'кириллица
    ElseIf cod > 64 And cod < 123 Then 'латиница
    ElseIf cod > 47 And cod < 58 Then 'цифры
    ElseIf InStr(smv, Chr(cod)) > 0 Then 'знаки
    ElseIf cod = 184 Then 'ё
    Else
      MsgBox "Недопустимый символ: " & Chr(cod) & " - код " & cod
      Sheets("Parts").Select: [smvList].Select
      Exit Function
    End If
  Next
  If rwOpts("dp") = 1 Then smv = "" 'если с пунктуацией, то вкл. в подсчёт знаки
  
  i = 0
  For Each eP In endP 'разбиваем текст по предложениям
    iText = Replace(iText, eP, Format(i, cE) & fs)
    i = i + 1
  Next
  iText = Left(iText, Len(iText) - 1)
  mT = Split(iText, fs)
  
  For i = 0 To UBound(mT) 'возвращаем конечные знаки
    eP = endP(Val(Right(mT(i), 2)))
    mT(i) = Trim(Left(mT(i), Len(mT(i)) - Len(cE))) & eP
  Next
  
  yes = 0 'запоминаем переход к след. отрывку
  p = rwOpts("np"): rwOpts "ap", p
  w = rwOpts("nw"): rwOpts "aw", w
    
  If optV = 3 Then 'разбивка по предложениям
    If pYES Then
          CropText = mT(p)
          rwOpts "np", p + 1
          rwOpts "nw", 0
    Else: mPs = mT
    End If
    GoTo finish
  End If

  If p > UBound(mT) Then GoTo finish

    For a = IIf(pYES, p, 0) To UBound(mT)
      While yes < lM 'собираем отрывок требуемой длины
        If w = 0 Or IsEmpty(tmp) Then tmp = Split(mT(a)) 'начали новое предложение
        If w <= UBound(tmp) Then 'не кончились ли слова в последнем предложении?
          yes = yes + opraz(tmp(w), optV, sW, musor, smv) 'считаем сколько собрали слов
          If Len(tmp(w)) > maxl Then 'для слишком длинного слова делаем топорное сокр-е
            tmp(w) = Left(tmp(w), maxl - 2) & "-" & Right(tmp(w), 1)
          End If
          txt = txt & " " & tmp(w) 'добавляем текущее слово в отрывок
          If w = UBound(tmp) Then 'последнее слово в предложении?
            w = 0
            If a < UBound(mT) Then a = a + 1 Else Exit For
          Else: w = w + 1 'переходим к след. предл.
          End If
        Else: yes = 999
        End If
      Wend
        
      yes = yes - lM
      For i = w To UBound(tmp) 'при необх., добавляем "хвостик"
        yes = yes + opraz(tmp(i), optV, sW, musor, smv)
        overT = overT & " " & tmp(i)
      Next
      If yes <= ovW Then
        w = 0: a = a + 1
        txt = txt & overT
      End If
      
     'Debug.Print "a=" & a, "p=" & p, "z=" & z, "w=" & w, Mid(txt, 2) 'для отладки
      If pYES Then 'если добрались до нужного отрывка
        CropText = Mid(txt, 2)
        rwOpts "np", a
        rwOpts "nw", w
        Exit For
      Else 'если функции нужно возвратить массив
        ReDim Preserve mPs(z)
        mPs(z) = txt
        z = z + 1
      End If
      yes = 0: txt = "": overT = "": musor = ""
      If optV = 5 Then w = 0 'разбивка по "огрызкам" :)
      If w > 0 And w < UBound(tmp) Then a = a - 1 'разбиваем всё текущее предложение
    Next
  
finish:
End Function

Function opraz(ByVal txt, ByVal optV, ByVal sW, musor, Optional smv) 'определение микроразмера
  If Len(smv) > 0 Then 'добавлять в длину пунктуацию?
    For i = 1 To Len(txt)
      s = Mid(txt, i, 1)
      tmp = tmp & IIf(InStr(smv, s) > 0, "", s)
    Next
  End If
  txt = tmp
  
  Select Case optV 'разбивать по...
    Case 1, 5: yes = yes - (Len(txt) >= sW) 'числу слов, первой фразе
    Case 2 'числу единиц
      If Len(txt) >= sW Then
        yes = yes + Len(txt) \ sW 'число вхождений дост. длины
      Else
        musor = musor & txt
        If Len(musor) >= sW Then yes = yes + 1: musor = ""
      End If
    Case 4 'числу слогов
      For b = 1 To Len(txt)
        If InStr("аеёиоуыэюяaeiouy", Mid(LCase(txt), b, 1)) > 0 Then yes = yes + 1
      Next
  End Select
  opraz = yes
End Function

Function IDclb(Optional out As Boolean = False)
 'Функция возвращает псевдоуникальный идентификатор буфера обмена
  Dim MyData As New DataObject
  MyData.GetFromClipboard
  On Error Resume Next 'антиFormatEtc
  txt = Trim(MyData.GetText(1))
  On Error GoTo 0
  If out Then IDclb = txt: Exit Function 'забираем буфер и сваливаем
  
  txt = Replace(Replace(txt, Chr(10), " "), Chr(13), " ") 'убираем абзацы
  If Len(txt) > 0 Then
    If InStr(txt, " ") Then 'в зависимости от объёма копипаста
      tmp = Split(txt)
      If Len(tmp(0)) < 4 Then tmp(0) = tmp(0) & " " & tmp(1)
      If Len(tmp(0)) > 10 Then tmp(0) = Left(tmp(0), 5)
      LI = UBound(tmp)
      If Len(tmp(LI)) < 4 Then tmp(LI) = tmp(LI) & " " & tmp(LI - 1)
      If Len(tmp(LI)) > 10 Then tmp(LI) = Left(tmp(LI), 5)
      IDclb = "<Clipboard: " & tmp(0) & "… " & tmp(LI) & " (" & Len(txt) & ")>"
    ElseIf Len(txt) > 10 Then
          IDclb = "<Clipboard: " & Left(txt, 3) & "…" & Right(txt, 3) & ">"
    Else: IDclb = "<Clipboard: " & txt & ">"
    End If
  Else
    IDclb = "<Clipboard>"
  End If
End Function
